home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / proc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-10-26  |  14.0 KB  |  557 lines
  1. /* Eval, funcall, apply, map, lambda, macro, etc.
  2.  */
  3.  
  4. #include "scheme.h"
  5.  
  6. #ifdef USE_ALLOCA
  7. #  define MAX_ARGS_ON_STACK  4
  8. #else
  9. #  define MAX_ARGS_ON_STACK  8
  10. #endif
  11.  
  12. char *Error_Tag;
  13.  
  14. /* Tail_Call indicates whether we are executing the last form in a
  15.  * sequence of forms.  If it is true and we are about to call a compound
  16.  * procedure, we are allowed to check whether a tail-call can be
  17.  * performed instead.
  18.  */
  19. int Tail_Call = 0;
  20.  
  21. Object Sym_Lambda,
  22.        Sym_Macro;
  23.  
  24. static Object tc_fun, tc_argl, tc_env;
  25.  
  26. Object Macro_Expand();
  27.  
  28. Init_Proc () {
  29.     Define_Symbol (&Sym_Lambda, "lambda");
  30.     Define_Symbol (&Sym_Macro, "macro");
  31. }
  32.  
  33. Check_Procedure (x) Object x; {
  34.     register t = TYPE(x);
  35.  
  36.     if (t != T_Primitive && t != T_Compound)
  37.     Wrong_Type_Combination (x, "procedure");
  38.     if (t == T_Primitive && PRIM(x)->disc == NOEVAL)
  39.     Primitive_Error ("invalid procedure: ~s", x);
  40. }
  41.  
  42. Object P_Procedurep (x) Object x; {
  43.     register t = TYPE(x);
  44.     return t == T_Primitive || t == T_Compound || t == T_Control_Point
  45.      ? True : False;
  46. }
  47.  
  48. Object P_Primitivep (x) Object x; {
  49.     return TYPE(x) == T_Primitive ? True : False;
  50. }
  51.  
  52. Object P_Compoundp (x) Object x; {
  53.     return TYPE(x) == T_Compound ? True : False;
  54. }
  55.  
  56. Object P_Macrop (x) Object x; {
  57.     return TYPE(x) == T_Macro ? True : False;
  58. }
  59.  
  60. Object Make_Compound () {
  61.     Object proc;
  62.  
  63.     proc = Alloc_Object (sizeof (struct S_Compound), T_Compound, 0);
  64.     COMPOUND(proc)->closure = COMPOUND(proc)->env = COMPOUND(proc)->name = Null;
  65.     return proc;
  66. }
  67.  
  68. Object Make_Primitive (fun, name, min, max, disc) Object (*fun)(); char *name;
  69.     enum discipline disc; {
  70.     Object prim;
  71.     register struct S_Primitive *pr;
  72.  
  73.     prim = Alloc_Object (sizeof (struct S_Primitive), T_Primitive, 0);
  74.     pr = PRIM(prim);
  75.     pr->tag = Null;
  76.     pr->fun = fun;
  77.     pr->name = name;
  78.     pr->minargs = min;
  79.     pr->maxargs = max;
  80.     pr->disc = disc;
  81.     return prim;
  82. }
  83.  
  84. Object Eval (form) Object form; {
  85.     register t;
  86.     register struct S_Symbol *sym;
  87.     Object fun, binding, args, ret;
  88.     GC_Node;
  89.  
  90. again:
  91.     t = TYPE(form);
  92.     if (t == T_Symbol) {
  93.     sym = SYMBOL(form);
  94.     if (EQ(sym->value,Unbound)) {
  95.         binding = Lookup_Symbol (form, 1);
  96.         sym->value = Cdr (binding);
  97.     }
  98.     ret = sym->value;
  99.     if (TYPE(ret) == T_Autoload)
  100.         ret = Do_Autoload (form, ret);
  101.     return ret;
  102.     }
  103.     if (t != T_Pair) {
  104.     if (t == T_Null)
  105.         Primitive_Error ("no subexpression in procedure call");
  106.     if (t == T_Vector)
  107.         Primitive_Error ("unevaluable object: ~s", form);
  108.     return form;
  109.     }
  110.     if (Stack_Size () > Max_Stack)
  111.     Uncatchable_Error ("Out of stack space");
  112.     GC_Link (form);
  113.     fun = Eval (Car (form));
  114.     args = Cdr (form);
  115.     Check_List (args);
  116.     if (TYPE(fun) == T_Macro) {
  117.     form = Macro_Expand (fun, args);
  118.     GC_Unlink;
  119.     goto again;
  120.     }
  121.     ret = Funcall (fun, args, 1);
  122.     GC_Unlink;
  123.     return ret;
  124. }
  125.  
  126. Object P_Eval (argc, argv) Object *argv; {
  127.     Object ret, oldenv;
  128.     GC_Node;
  129.  
  130.     if (argc == 1)
  131.     return Eval (argv[0]);
  132.     Check_Type (argv[1], T_Environment);
  133.     oldenv = The_Environment;
  134.     GC_Link (oldenv);
  135.     Switch_Environment (argv[1]);
  136.     ret = Eval (argv[0]);
  137.     Switch_Environment (oldenv);
  138.     GC_Unlink;
  139.     return ret;
  140. }
  141.  
  142. Object P_Apply (argc, argv) Object *argv; {
  143.     Object ret, list, tail, cell, last;
  144.     register i;
  145.     GC_Node3;
  146.  
  147.     Check_Procedure (argv[0]);
  148.     /* Make a list of all args but the last, then append the
  149.      * last arg (which must be a proper list) to this list.
  150.      */
  151.     list = tail = last = Null;
  152.     GC_Link3 (list, tail, last);
  153.     for (i = 1; i < argc-1; i++, tail = cell) {
  154.     cell = Cons (argv[i], Null);
  155.     if (Nullp (list))
  156.         list = cell;
  157.     else
  158.         (void)P_Setcdr (tail, cell);
  159.     }
  160.     for (last = argv[argc-1]; !Nullp (last); last = Cdr (last), tail = cell) {
  161.     cell = Cons (P_Car (last), Null);
  162.     if (Nullp (list))
  163.         list = cell;
  164.     else
  165.         (void)P_Setcdr (tail, cell);
  166.     }
  167.     ret = Funcall (argv[0], list, 0);
  168.     GC_Unlink;
  169.     return ret;
  170. }
  171.  
  172. Arglist_Length (list) Object list; {
  173.     Object tail;
  174.     register i;
  175.  
  176.     for (i = 0, tail = list; TYPE(tail) == T_Pair; tail = Cdr (tail), i++)
  177.     ;
  178.     if (Nullp (tail))
  179.     return i;
  180.     Primitive_Error ("argument list is improper");
  181.     /*NOTREACHED*/
  182. }
  183.  
  184. Object Funcall_Primitive (fun, argl, eval) Object fun, argl; {
  185.     register struct S_Primitive *prim;
  186.     register argc, i;
  187.     char *last;
  188.     Object *argv;
  189.     Object abuf[MAX_ARGS_ON_STACK], ret;
  190.     GC_Node2; GCNODE gcv;
  191.     TC_Prolog;
  192.     Alloca_Begin;
  193.  
  194.     prim = PRIM(fun);
  195.     last = Error_Tag;
  196.     Error_Tag = prim->name;
  197.     argc = Arglist_Length (argl);
  198.     if (argc < prim->minargs
  199.         || (prim->maxargs != MANY && argc > prim->maxargs))
  200.     Primitive_Error ("wrong number of arguments");
  201.     if (prim->disc == NOEVAL) {
  202.     ret = (prim->fun)(argl);
  203.     } else {
  204.     /* Tail recursion is not possible while evaluating the arguments
  205.      * of a primitive procedure.
  206.      */
  207.     TC_Disable;
  208.     if (argc <= MAX_ARGS_ON_STACK)
  209.         argv = abuf;
  210.     else
  211.         Alloca (argv, Object*, argc * sizeof (Object));
  212.     GC_Link2 (argl, fun);
  213.     gcv.gclen = 1; gcv.gcobj = argv; gcv.next = &gc2; GC_List = &gcv;
  214.     for (i = 0; i < argc; i++, argl = Cdr (argl)) {
  215.         argv[i] = eval ? Eval (Car (argl)) : Car (argl);
  216.         gcv.gclen++;
  217.     }
  218.     TC_Enable;
  219.     prim = PRIM(fun);   /* fun has possibly been moved during gc */
  220.     if (prim->disc == VARARGS) {
  221.         ret = (prim->fun)(argc, argv);
  222.     } else {
  223.         switch (argc) {
  224.         case 0:
  225.         ret = (prim->fun)(); break;
  226.         case 1:
  227.         ret = (prim->fun)(argv[0]); break;
  228.         case 2:
  229.         ret = (prim->fun)(argv[0], argv[1]); break;
  230.         case 3:
  231.         ret = (prim->fun)(argv[0], argv[1], argv[2]); break;
  232.         case 4:
  233.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3]); break;
  234.         case 5:
  235.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4]);
  236.         break;
  237.         case 6:
  238.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  239.                           argv[5]); break;
  240.         case 7:
  241.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  242.                           argv[5], argv[6]); break;
  243.         case 8:
  244.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  245.                           argv[5], argv[6], argv[7]); break;
  246.         case 9:
  247.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  248.                           argv[5], argv[6], argv[7], argv[8]); break;
  249.         case 10:
  250.         ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
  251.                           argv[5], argv[6], argv[7], argv[8], argv[9]);
  252.         break;
  253.         default:
  254.         Panic ("too many args for primitive");
  255.         }
  256.     }
  257.     GC_Unlink;
  258.     Alloca_End;
  259.     }
  260.     Error_Tag = last;
  261.     return ret;
  262. }
  263.  
  264. /* If we are in a tail recursion, we are reusing the old procedure
  265.  * frame; we just assign new values to the formal parameters:
  266.  */
  267. #define Lambda_Bind(var,val)\
  268. if (tail_calling) {\
  269.     newframe = Add_Binding (newframe, var, val);\
  270. } else {\
  271.     frame = Add_Binding (frame, var, val);\
  272. }
  273.  
  274. Object Funcall_Compound (fun, argl, eval) Object fun, argl; {
  275.     register argc, min, max, i, tail_calling = 0;
  276.     Object *argv, abuf[MAX_ARGS_ON_STACK], rest, ret, frame,
  277.     tail, tail_call_env, oldenv, newframe;
  278.     GC_Node6; GCNODE gcv;
  279.     TC_Prolog;
  280.     Alloca_Begin;
  281.  
  282. #ifdef lint
  283.     tail_call_env = Null;
  284. #endif
  285.     frame = oldenv = tail = newframe = Null;
  286.     GC_Link6 (argl, oldenv, frame, tail, fun, newframe);
  287. again:
  288.     argc = Arglist_Length (argl);
  289.     min = COMPOUND(fun)->min_args;
  290.     max = COMPOUND(fun)->max_args;
  291.     if (argc < min)
  292.     Primitive_Error ("too few arguments for ~s", fun);
  293.     if (max >= 0 && argc > max)
  294.     Primitive_Error ("too many arguments for ~s", fun);
  295.     if (tail_calling) {
  296.     tail = The_Environment;
  297.     Switch_Environment (tail_call_env);
  298.     } else {
  299.     if (argc <= MAX_ARGS_ON_STACK)
  300.         argv = abuf;
  301.     else
  302.         Alloca (argv, Object*, argc * sizeof (Object));
  303.     }
  304.     TC_Disable;
  305.     gcv.gclen = 1; gcv.gcobj = argv; gcv.next = &gc6; GC_List = &gcv;
  306.     for (i = 0; i < argc; i++, argl = Cdr (argl)) {
  307.     argv[i] = eval ? Eval (Car (argl)) : Car (argl);
  308.     gcv.gclen++;
  309.     }
  310.     TC_Enable;
  311.     if (tail_calling)
  312.     Switch_Environment (tail);
  313.     tail = Car (Cdr (COMPOUND(fun)->closure));
  314.     for (i = 0; i < min; i++, tail = Cdr (tail))
  315.     Lambda_Bind (Car (tail), argv[i]);
  316.     if (max == -1) {
  317.     rest = P_List (argc-i, argv+i);
  318.     Lambda_Bind (tail, rest);
  319.     }
  320.     if (tail_calling) {
  321.     Pop_Frame ();
  322.     Push_Frame (newframe);
  323.     } else {
  324.     oldenv = The_Environment;
  325.     Switch_Environment (COMPOUND(fun)->env);
  326.         Push_Frame (frame);
  327.     }
  328.  
  329.     Tail_Call = 1;
  330.     ret = Begin (Cdr (Cdr (COMPOUND(fun)->closure)));
  331.     /*
  332.      * If evaluation of the function body returned a T_Special object,
  333.      * a tail-call has been taken place.  If it is a tail-call to a
  334.      * different function, just return, otherwise unpack new arguments
  335.      * and environment and jump to the beginning.
  336.      */
  337.     if (TYPE(ret) == T_Special && EQ(fun, tc_fun)) {
  338.     argl = tc_argl;
  339.     tail_call_env = tc_env;
  340.     tail_calling = 1;
  341.     eval = 1;
  342.     newframe = Null;
  343.     goto again;
  344.     }
  345.     Tail_Call = 0;
  346.     Pop_Frame ();
  347.     Switch_Environment (oldenv);
  348.     GC_Unlink;
  349.     Alloca_End;
  350.     return ret;
  351. }
  352.  
  353. Object Funcall (fun, argl, eval) Object fun, argl; {
  354.     register t;
  355.     register GCNODE *p;
  356.     Object ret, env;
  357.     Tag_Node;
  358.  
  359.     t = TYPE(fun);
  360.     /* Search upwards in the GC list for a TAG frame pointing to
  361.      * the function we are abount to call.  Stop if a TAG frame
  362.      * is encountered that points to a function call that is not
  363.      * in a tail-call position.
  364.      *
  365.      * If the search succeeds, package up function, actual arguments,
  366.      * and environment, and return a T_Special object.
  367.      */
  368.     if (Tail_Call && eval && t == T_Compound) {
  369.     for (p = GC_List; p && p->gclen != TAG_FUN; p = p->next) {
  370.         if (p->gclen == TAG_TCFUN && EQ(*(p->gcobj), fun)) {
  371.         SET(ret, T_Special, 0);
  372.         tc_fun = fun; tc_argl = argl; tc_env = The_Environment;
  373.         return ret;
  374.         }
  375.     }
  376.     }
  377.     env = The_Environment;
  378.     Tag_Link (argl, fun, env);
  379.     if (t == T_Primitive) {
  380.     ret = Funcall_Primitive (fun, argl, eval);
  381.     } else if (t == T_Compound) {
  382.     ret = Funcall_Compound (fun, argl, eval);
  383.     } else if (t == T_Control_Point) {
  384.     Funcall_Control_Point (fun, argl, eval);
  385.     /*NOTREACHED*/
  386.     } else Primitive_Error ("application of non-procedure: ~s", fun);
  387.     Tag_Unlink;
  388.     return ret;
  389. }
  390.  
  391. Check_Formals (x, min, max) Object x; int *min, *max; {
  392.     Object s, t1, t2;
  393.  
  394.     *min = *max = 0;
  395.     for (t1 = Car (x); !Nullp (t1); t1 = Cdr (t1)) {
  396.         s = TYPE(t1) == T_Pair ? Car (t1) : t1;
  397.     Check_Type (s, T_Symbol);
  398.     for (t2 = Car (x); t2 != t1; t2 = Cdr (t2))
  399.         if (EQ(s, Car (t2)))
  400.         Primitive_Error ("~s: duplicate variable binding", s);
  401.     if (TYPE(t1) != T_Pair)
  402.         break;
  403.     (*min)++; (*max)++;
  404.     }
  405.     if (TYPE(t1) == T_Symbol)
  406.     *max = -1;
  407.     else if (!Nullp (t1))
  408.     Wrong_Type_Combination (t1, "list or symbol");
  409. }
  410.  
  411. Object P_Lambda (argl) Object argl; {
  412.     Object proc, closure;
  413.     GC_Node2;
  414.  
  415.     proc = Null;
  416.     GC_Link2 (argl, proc);
  417.     proc = Make_Compound ();
  418.     closure = Cons (Sym_Lambda, argl);
  419.     COMPOUND(proc)->closure = closure;
  420.     COMPOUND(proc)->env = The_Environment;
  421.     Check_Formals (argl, &COMPOUND(proc)->min_args,
  422.     &COMPOUND(proc)->max_args);
  423.     GC_Unlink;
  424.     return proc;
  425. }
  426.  
  427. Object P_Procedure_Lambda (p) Object p; {
  428.     Check_Type (p, T_Compound);
  429.     return Copy_List (COMPOUND(p)->closure);
  430. }
  431.  
  432. Object P_Procedure_Env (p) Object p; {
  433.     Check_Type (p, T_Compound);
  434.     return COMPOUND(p)->env;
  435. }
  436.  
  437. Object General_Map (argc, argv, accum) Object *argv; register accum; {
  438.     register i;
  439.     Object *args;
  440.     Object head, list, tail, cell, arglist, val;
  441.     GC_Node2; GCNODE gcv;
  442.     TC_Prolog;
  443.     Alloca_Begin;
  444.  
  445.     Check_Procedure (argv[0]);
  446.     Alloca (args, Object*, (argc-1) * sizeof (Object));
  447.     list = tail = Null;
  448.     GC_Link2 (list, tail);
  449.     gcv.gclen = argc; gcv.gcobj = args; gcv.next = &gc2; GC_List = &gcv;
  450.     while (1) {
  451.     for (i = 1; i < argc; i++) {
  452.         head = argv[i];
  453.         if (Nullp (head)) {
  454.         GC_Unlink;
  455.         Alloca_End;
  456.         return list;
  457.         }
  458.         Check_Type (head, T_Pair);
  459.         args[i-1] = Car (head);
  460.         argv[i] = Cdr (head);
  461.     }
  462.     arglist = P_List (argc-1, args);
  463.     TC_Disable;
  464.     val = Funcall (argv[0], arglist, 0);
  465.     TC_Enable;
  466.     if (!accum)
  467.         continue;
  468.     cell = Cons (val, Null);
  469.     if (Nullp (list))
  470.         list = cell;
  471.     else
  472.         (void)P_Setcdr (tail, cell);
  473.     tail = cell;
  474.     }
  475.     /*NOTREACHED*/
  476. }
  477.  
  478. Object P_Map (argc, argv) Object *argv; {
  479.     return General_Map (argc, argv, 1);
  480. }
  481.  
  482. Object P_For_Each (argc, argv) Object *argv; {
  483.     return General_Map (argc, argv, 0);
  484. }
  485.  
  486. Object Make_Macro () {
  487.     Object mac;
  488.  
  489.     mac = Alloc_Object (sizeof (struct S_Macro), T_Macro, 0);
  490.     MACRO(mac)->body = MACRO(mac)->name = Null;
  491.     return mac;
  492. }
  493.  
  494. Object P_Macro (argl) Object argl; {
  495.     Object mac, body;
  496.     GC_Node2;
  497.  
  498.     mac = Null;
  499.     GC_Link2 (argl, mac);
  500.     mac = Make_Macro ();
  501.     body = Cons (Sym_Macro, argl);
  502.     MACRO(mac)->body = body;
  503.     Check_Formals (argl, &MACRO(mac)->min_args, &MACRO(mac)->max_args);
  504.     GC_Unlink;
  505.     return mac;
  506. }
  507.  
  508. Object P_Macro_Body (m) Object m; {
  509.     Check_Type (m, T_Macro);
  510.     return Copy_List (MACRO(m)->body);
  511. }
  512.  
  513. Object Macro_Expand (mac, argl) Object mac, argl; {
  514.     register argc, min, max, i, tail_calling = 0;
  515.     Object frame, ret, tail;
  516.     Object newframe; /* not used; see Lambda_Bind() */
  517.     GC_Node4;
  518.     TC_Prolog;
  519.  
  520.     frame = tail = Null;
  521.     GC_Link4 (argl, frame, tail, mac);
  522.     argc = Arglist_Length (argl);
  523.     min = MACRO(mac)->min_args;
  524.     max = MACRO(mac)->max_args;
  525.     if (argc < min)
  526.     Primitive_Error ("too few arguments for ~s", mac);
  527.     if (max >= 0 && argc > max)
  528.     Primitive_Error ("too many arguments for ~s", mac);
  529.     tail = Car (Cdr (MACRO(mac)->body));
  530.     for (i = 0; i < min; i++, tail = Cdr (tail), argl = Cdr (argl))
  531.     Lambda_Bind (Car (tail), Car (argl));
  532.     if (max == -1)
  533.     Lambda_Bind (tail, argl);
  534.     Push_Frame (frame);
  535.     TC_Disable;
  536.     ret = Begin (Cdr (Cdr (MACRO(mac)->body)));
  537.     TC_Enable;
  538.     Pop_Frame ();
  539.     GC_Unlink;
  540.     return ret;
  541. }
  542.  
  543. Object P_Macro_Expand (form) Object form; {
  544.     Object ret, mac;
  545.     GC_Node;
  546.  
  547.     Check_Type (form, T_Pair);
  548.     GC_Link (form);
  549.     mac = Eval (Car (form));
  550.     if (TYPE(mac) != T_Macro)
  551.     ret = form;
  552.     else
  553.     ret = Macro_Expand (mac, Cdr (form));
  554.     GC_Unlink;
  555.     return ret;
  556. }
  557.